home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / 3a.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  58KB  |  1,827 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "3.h"
  11. #include "attr.h"
  12. #include "arithp.h"
  13. #include "miscp.h"
  14. #include "smiscp.h"
  15. #include "dclmapp.h"
  16. #include "nodesp.h"
  17. #include "errmsgp.h"
  18. #include "evalp.h"
  19. #include "setp.h"
  20. #include "chapp.h"
  21.  
  22. extern int *ADA_MIN_FIXED_MP, *ADA_MAX_FIXED_MP;
  23.  
  24. static void const_redecl(Node, Node, Node);
  25. static Symbol set_type_mark(Tuple, Node);
  26. static void build_type(Symbol, Node, Node);
  27. static void derived_type(Symbol, Node);
  28. static void build_derived_type(Symbol, Symbol, Node);
  29. static int in_unconstrained_natures(int);
  30. static int is_derived_type(Symbol);
  31. static void derive_subprograms(Symbol, Symbol);
  32. static void derive1_subprogram(Symbol, Symbol, Symbol, Symbol);
  33. static int hidden_derived(Symbol, Symbol);
  34. static Symbol find_neq(Symbol);
  35. static void new_enum_type(Symbol, Node);
  36. static void new_integer_type(Symbol, Node);
  37. static void new_floating_type(Symbol, Node);
  38. static void new_fixed_type(Symbol, Node);
  39. static Node real_bound(Node, Symbol);
  40. static Symbol constrain_scalar(Symbol, Node);
  41.  
  42. void obj_decl(Node node)                                     /*;obj_decl*/
  43. {
  44.     /* Process variable declaration. Verify that the type is a constrained one,
  45.      * or that default values exist for the discriminants of the type.
  46.      */
  47.  
  48.     Node id_list_node, type_indic_node, init_node, id_node, node1;
  49.     Symbol    type_mark, t_m, n;
  50.     int i;
  51.     Tuple    nam_list, id_nodes;
  52.     Fortup    ft1;
  53.  
  54.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : obj_decl");
  55.  
  56.     id_list_node  = N_AST1(node);
  57.     type_indic_node     = N_AST2(node);
  58.     init_node = N_AST3(node);
  59.  
  60.     id_nodes = N_LIST(id_list_node);
  61.     nam_list = tup_new(tup_size(id_nodes));
  62.     FORTUPI(id_node =(Node) , id_nodes, i,  ft1);
  63.         nam_list[i] = (char *) find_new(N_VAL(id_node));
  64.     ENDFORTUP(ft1);
  65.     type_mark = set_type_mark(nam_list, type_indic_node);
  66.  
  67.     current_node = type_indic_node;
  68.     check_fully_declared(type_mark);
  69.     adasem(init_node);
  70.  
  71.     /* If an initialization is provided, verify it has the specified type.  */
  72.     if (init_node != OPT_NODE)
  73.         t_m = check_init(type_indic_node, init_node);
  74.  
  75.     if (is_unconstrained(type_mark)) {
  76.         errmsg_nat("Unconstrained % in object declaration", type_mark,
  77.           "3.6.1, 3.7.2", type_indic_node);
  78.     }
  79.  
  80.     /*(forall n in nam_list) nature(n) := na_obj; end forall;*/
  81.     FORTUP(n=(Symbol), nam_list, ft1);
  82.         NATURE(n) = na_obj;
  83.     ENDFORTUP(ft1);
  84.     for (i = 1; i <= tup_size(id_nodes); i++) {
  85.         node1 = (Node) id_nodes[i];
  86.         N_UNQ(node1) = (Symbol) nam_list[i];
  87.     }
  88. }
  89.  
  90. void const_decl(Node node)                              /*;const_decl*/
  91. {
  92.     /* Process constant declarations. This may be a new declaration, or the
  93.      * full declaration of a deferred constant in the private part of a
  94.      * package. In this later case, recover the names of the constants, and
  95.      * update their definitions.
  96.      */
  97.  
  98.     Node    id_list_node, type_indic_node, init_node, id_node;
  99.     Tuple    id_nodes, id_list, nam_list;
  100.     Symbol    type_mark, t_m, n;
  101.     char    *id;
  102.     int    i, exists;
  103.     Fortup    ft1;
  104.     Symbol    s;
  105.  
  106.     if (cdebug2 > 3)  TO_ERRFILE("AT PROC : const_decl");
  107.  
  108.     id_list_node = N_AST1(node);
  109.     type_indic_node = N_AST2(node);
  110.     init_node = N_AST3(node);
  111.  
  112.     id_nodes = N_LIST(id_list_node);
  113.     id_list = tup_new(tup_size(id_nodes));
  114.     FORTUPI(id_node =(Node), id_nodes, i, ft1);
  115.         id_list[i] = N_VAL(id_node);
  116.     ENDFORTUP(ft1);
  117.     adasem(init_node);
  118.  
  119.     if (NATURE(scope_name) == na_private_part) {
  120.         exists = FALSE;
  121.         FORTUP(id=, id_list, ft1);
  122.             if (dcl_get(DECLARED(scope_name), id) != (Symbol)0) {
  123.                 exists = TRUE;
  124.                 break;
  125.             }
  126.         ENDFORTUP(ft1);
  127.         if (exists ){
  128.             /* It must be a deferred constant. */
  129.             const_redecl(id_list_node, type_indic_node, init_node);
  130.             return;
  131.             /* Otherwise it is a fully private constant. */
  132.         }
  133.     }
  134.  
  135.     nam_list = tup_new(tup_size(id_list));
  136.     FORTUPI(id =, id_list, i, ft1);
  137.         nam_list[i] = (char *) find_new(id);
  138.     ENDFORTUP(ft1);
  139.  
  140.     type_mark = set_type_mark(nam_list, type_indic_node);
  141.  
  142.     if (init_node == OPT_NODE) {
  143.         /* Deferred constant.*/
  144.         s = TYPE_OF(base_type(type_mark));
  145.         if (s != symbol_private && s != symbol_limited_private) {
  146.             errmsg("Missing initialization in constant declaration", "3.2",
  147.               node);
  148.         }
  149.         else if (SCOPE_OF(type_mark) != scope_name) {
  150.             errmsg("Wrong scope for type of deferred constant", "7.4",
  151.               type_indic_node);
  152.         }
  153.         else if ( (NATURE(scope_name) != na_package_spec)
  154.           && (NATURE(scope_name) != na_generic_package_spec) ) {
  155.             errmsg("Invalid context for deferred constant", "3.2, 7.4", node);
  156.         }
  157.         else if (is_generic_type(type_mark)
  158.           || is_generic_type(base_type(type_mark))) { 
  159.             errmsg("constants of a generic type cannot be deferred", "12.1.2",
  160.               node);
  161.         }
  162.         else if (is_anonymous(type_mark)) {
  163.             errmsg("a deferred constant must be defined with a type mark",
  164.               "7.4.3", node);
  165.         }
  166.     }
  167.     else {
  168.         t_m = check_init(type_indic_node, init_node);
  169.  
  170.         if (t_m != type_mark) {
  171.             /* t_m is an anonymous type created from the bounds of init value*/
  172.             FORTUP(n = (Symbol), nam_list, ft1);
  173.                 TYPE_OF(n) = t_m;
  174.             ENDFORTUP(ft1);
  175.         }
  176.     }
  177.  
  178.     FORTUP(n =(Symbol), nam_list, ft1);
  179.         NATURE(n) = na_constant;
  180.         SIGNATURE(n) = (Tuple) init_node;
  181.     ENDFORTUP(ft1);
  182.     for (i = 1; i <= tup_size(id_nodes); i++) {
  183.         Node tmp = (Node) id_nodes[i];
  184.         N_UNQ(tmp) = (Symbol) nam_list[i];
  185.     }
  186. }
  187.  
  188. static void const_redecl(Node id_list_node, Node type_indic_node,
  189.   Node init_node)                                             /*;const_redecl*/
  190. {
  191.     /* Process the full declaration of deferred constants. at least one id
  192.      * in  id_list is know to have been declared in the visible part of the
  193.      * current scope.
  194.      */
  195.  
  196.     Symbol    u_n, t_m, type_mark;
  197.     Symbol    ut;
  198.     Node    id_node, tmp;
  199.     Tuple    id_nodes, nam_list, id_list;
  200.     char    *id;
  201.     int    i;
  202.     Fortup    ft1;
  203.  
  204.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : const_redecl");
  205.  
  206.     id_nodes = N_LIST(id_list_node);
  207.     id_list = tup_new(tup_size(id_nodes));
  208.     FORTUPI(id_node =(Node), id_nodes, i, ft1);
  209.         id_list[i]  = N_VAL(id_node);
  210.     ENDFORTUP(ft1);
  211.     nam_list = tup_new(0);
  212.     /* The type indication must be a subtype indication .*/
  213.  
  214.     if (N_KIND(type_indic_node) == as_subtype_indic) {
  215.         adasem(type_indic_node);
  216.         type_mark = promote_subtype(make_subtype(type_indic_node));
  217.     }
  218.     else
  219.         /* An anonymous array is syntactically possible, but incorrect. */
  220.         type_mark = anonymous_array(type_indic_node);
  221.  
  222.     N_UNQ(type_indic_node) = type_mark;
  223.  
  224.     FORTUP(id =, id_list, ft1);
  225.         u_n = dcl_get(DECLARED(scope_name), id);
  226.         if (u_n == (Symbol)0) {
  227.             errmsg_str("% is not a deferred constant", id, "3.2, 7.4",
  228.               id_list_node);
  229.             nam_list = tup_with(nam_list, (char *)symbol_any);
  230.             continue;
  231.         }
  232.         else if((NATURE(u_n) != na_constant)
  233.           || ((Node) SIGNATURE(u_n) != OPT_NODE)) {
  234.             errmsg_str("Invalid redeclaration of %", id, "8.3", id_list_node);
  235.             nam_list = tup_with(nam_list, (char *)symbol_any);
  236.             continue;
  237.         }
  238.         else if ( ((ut = TYPE_OF(u_n)) != type_mark)
  239.           /* They may still be the same subtype of some private type.*/
  240.           && (TYPE_OF(ut) != TYPE_OF(type_mark))
  241.           || (SIGNATURE(ut) != SIGNATURE(type_mark)))
  242.         {
  243.             errmsg_str("incorrect type in redeclaration of %", id,
  244.               "7.4, 7.4.1", id_list_node);
  245.             nam_list = tup_with(nam_list, (char *)symbol_any);
  246.         }
  247.         else if (init_node == OPT_NODE) {    /* No initiali(zation ? */
  248.             errmsg_str("Missing initialization in redeclaration of %", id,
  249.               "7.4", id_list_node);
  250.             nam_list = tup_with(nam_list, (char *)symbol_any);
  251.         }
  252.         else {
  253.             TO_XREF(u_n);
  254.             nam_list = tup_with(nam_list, (char *)  u_n);
  255.         }
  256.     ENDFORTUP(ft1);
  257.  
  258.     for (i = 1; i <= tup_size(id_nodes); i++) {
  259.         tmp = (Node) id_nodes[i];
  260.         N_UNQ(tmp ) = (Symbol) nam_list[i];
  261.     }
  262.  
  263.     if (init_node != OPT_NODE ) {
  264.         t_m = check_init(type_indic_node, init_node);
  265.         FORTUP(u_n=(Symbol), nam_list, ft1);
  266.             SIGNATURE(u_n) = (Tuple) init_node;
  267.         ENDFORTUP(ft1);
  268.     }
  269. }
  270.  
  271. static Symbol set_type_mark(Tuple nam_list, Node type_indic_node)
  272.                                                             /*;set_type_mark*/
  273. {
  274.     /* Set the symbol table entry for object or constant declarations.
  275.      * The type indication is a subtype indication or an array definition. In
  276.      * the later case, an anonymous array type must be created for each item
  277.      * in the name list. For the interpreter, any of these types will do.
  278.      */
  279.  
  280.     Symbol    type_mark, n;
  281.     Fortup    ft1;
  282.  
  283.     if (N_KIND(type_indic_node) == as_subtype_indic) {
  284.         adasem(type_indic_node);
  285.         type_mark = promote_subtype(make_subtype(type_indic_node));
  286.         FORTUP(n=(Symbol), nam_list, ft1);
  287.             TYPE_OF(n) = type_mark;
  288.         ENDFORTUP(ft1);
  289.     }
  290.     else {
  291.         n = (Symbol) nam_list[1];
  292.         type_mark = anonymous_array(type_indic_node);
  293.         TYPE_OF(n) = type_mark;
  294.     }
  295.  
  296.     N_UNQ(type_indic_node) = type_mark;
  297.     return type_mark;
  298. }
  299.  
  300. Symbol check_init(Node type_indic_node, Node init_node)    /*;check_init*/
  301. {
  302.     /* Validate the initialization of an object or constant declaration.
  303.      * Return the resolved expression, and the type (or a subtype of it
  304.      * in the case of constants of unconstrained type).
  305.      */
  306.     Symbol    type_mark;
  307.     Tuple    init_array;
  308.     Fortup    ft1;
  309.     int    lo_val, hi_val;
  310.     Tuple    new_indices, tup;
  311.     Symbol    index, new_index, new_array;
  312.     Node    lo, hi;
  313.  
  314.     type_mark = N_UNQ(type_indic_node);
  315.  
  316.     if (is_limited_type(type_mark)) {
  317.         errmsg("Initialization not available for entities of limited type",
  318.           "7.4.4", type_indic_node);
  319.     }
  320.  
  321.     check_type(type_mark, init_node);
  322.  
  323.     if (NATURE(type_mark) == na_array && type_mark == symbol_string
  324.       && (N_KIND(init_node) == as_string_ivalue )) {
  325.         /* Constant definition with unconstrained type: bounds are given by 
  326.             * an aggregate :  Create an anonymous subtype using  bounds of
  327.          * aggregate.  Currently supported for strings only. 
  328.          */
  329.         init_array = (Tuple) N_VAL(init_node);
  330.  
  331.         new_indices = tup_new(0);
  332.         /* Unpack aggregate to obtain actual bounds on each dimension,
  333.          * and create constrained index for each.
  334.          * TBSL.
  335.          */
  336.         FORTUP(index=(Symbol), (Tuple)index_types(type_mark), ft1);
  337.             if (N_KIND(init_node) == as_string_ivalue  
  338.                  && base_type(type_mark) == symbol_string) {
  339.                 lo_val = 1;
  340.                 hi_val = tup_size( init_array);
  341.             }
  342.             else
  343.                 tup = init_array;
  344.                 /* TBSL */
  345.  
  346.             new_index = anonymous_type(); /* Its new subtype. */
  347.  
  348.             lo = new_ivalue_node(int_const(lo_val), symbol_integer);
  349.             hi = new_ivalue_node(int_const(hi_val), symbol_integer);
  350.  
  351.             NATURE(new_index)  = na_subtype;
  352.             TYPE_OF(new_index) = index;
  353.             { 
  354.                 Tuple t;
  355.                 t = constraint_new(CONSTRAINT_RANGE);
  356.                 numeric_constraint_low(t) = (char *) lo;
  357.                 numeric_constraint_high(t) = (char *) hi;
  358.                 SIGNATURE(new_index) = (Tuple) t;
  359.             }
  360.             root_type(new_index) = root_type(index);
  361.             new_indices = tup_with(new_indices, (char *) new_index);
  362.         ENDFORTUP(ft1);
  363.         new_array = anonymous_type();
  364.         NATURE(new_array) = na_subtype;
  365.         TYPE_OF(new_array) = type_mark;
  366.         { 
  367.             Tuple t; 
  368.             t = tup_new(2);
  369.             t[1] = (char *) new_indices;
  370.             t[2] = (char *) component_type(type_mark);
  371.             SIGNATURE(new_array) = t;
  372.         };
  373.         root_type(new_array) = root_type(type_mark);
  374.         misc_type_attributes(new_array) = misc_type_attributes(type_mark);
  375.  
  376.         type_mark = new_array;
  377.         N_TYPE(init_node) = type_mark;
  378.         N_UNQ(type_indic_node) = type_mark;
  379.     }
  380.     return type_mark;
  381. }
  382.  
  383. int is_deferred_constant(Node con_node)                /*;is_deferred_constant*/
  384. {
  385.     return
  386.       (N_KIND(con_node) == as_simple_name)
  387.       && (NATURE(N_UNQ(con_node)) == na_constant)
  388.       && ((Node) SIGNATURE(N_UNQ(con_node)) == OPT_NODE);
  389. }
  390.  
  391. void number_decl(Node node) /*;number_decl*/
  392. {
  393.     /* A number declaration differs from a constant declaration in that
  394.      * the type of the declared object is a universal numeric type, obtained
  395.      * from the value of the  literal expression supplied for it.
  396.      * No intermediate code is generated for these: they act as macros,
  397.      * and are always represented by their value.
  398.      */
  399.  
  400.     Node    id_list_node, expn, id_node;
  401.     Symbol    number_type, n;
  402.     Tuple    nam_list;
  403.     Fortup    ft1;
  404.     int    i;
  405.  
  406.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : number_decl");
  407.  
  408.     id_list_node = N_AST1(node);
  409.     expn = N_AST2(node);
  410.  
  411.     nam_list = tup_new(tup_size(N_LIST(id_list_node)));
  412.     FORTUPI(id_node =(Node), N_LIST(id_list_node), i, ft1);
  413.         nam_list[i] = (char *)find_new(N_VAL(id_node));
  414.     ENDFORTUP(ft1);
  415.     adasem(expn);
  416.     check_type_u( expn);
  417.     number_type = N_TYPE(expn);
  418.     if (! is_static_expr(expn)) {
  419.         errmsg("Expect literal expression in number declaration", "3.2", expn);
  420.         number_type = symbol_any;
  421.     }
  422.  
  423.     FORTUP(n=(Symbol), nam_list, ft1);
  424.         /*??SYMBTAB(n) = [na_constant, number_type, expn];*/
  425.         NATURE(n) = na_constant;
  426.         TYPE_OF(n) = number_type;
  427.         SIGNATURE(n) = (Tuple) expn;
  428.     ENDFORTUP(ft1);
  429. }
  430.  
  431. void type_decl(Node node)     /*;type_decl*/
  432. {
  433.     /* Process a type declaration. Create new name for type, or find unique
  434.      * name already given for incomplete declaration.
  435.      */
  436.  
  437.     Node    id_node, opt_disc, type_def;
  438.     Symbol    type_name, kind, d_type;
  439.  
  440.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : type_decl");
  441.  
  442.     id_node = N_AST1(node);
  443.     opt_disc = N_AST2(node);
  444.     type_def  = N_AST3(node);
  445.  
  446.     type_name = find_type_name(id_node);
  447.     sem_list(opt_disc);
  448.  
  449.     if (type_name == symbol_any) return;    /* Invalid redeclaration, etc. */
  450.  
  451.     root_type(type_name) = type_name;     /* initial value */
  452.  
  453.     if (opt_disc != OPT_NODE) {
  454.         if ( in_incp_types(TYPE_OF(type_name)))
  455.             /* Full declaration of incomplete or private type. Verify that
  456.              * discriminant declarations are conforming .
  457.              */
  458.             discr_redecl(type_name, opt_disc);
  459.         else if (N_KIND(type_def) == as_derived_type)
  460.             NATURE(type_name) = na_record;
  461.     }
  462.     else if (in_incp_types(TYPE_OF(type_name)) && has_discriminants(type_name)){
  463.         errmsg("missing discriminants in full type declaration", "3.8", node);
  464.     }
  465.  
  466.     kind = TYPE_OF(type_name);
  467.  
  468.     build_type(type_name, opt_disc, type_def);
  469.  
  470.     if (opt_disc != OPT_NODE && !is_record(type_name)) {
  471.         errmsg("Invalid use of discriminants", "3.7.1", opt_disc);
  472.     }
  473.     if ((N_KIND(type_def) == as_int_type || N_KIND(type_def) == as_float_type
  474.       || N_KIND(type_def) == as_fixed_type)
  475.       ||( N_KIND(type_def) == as_derived_type
  476.       && NATURE(type_name) == na_subtype)) {
  477.         /* these declarations generate an anonyous parent type. The named
  478.          * type is actually a subtype.
  479.          */
  480.         N_KIND(node) = as_subtype_decl;
  481.         /* preserve subtype info in n_ast3 by moving to n_ast2 
  482.          * Since none of these types have a discriminant 
  483.          * no information is lost.
  484.          */
  485.         N_AST2(node) = N_AST3(node);
  486.         N_AST3(node) = (Node)0; /* subtype_decl has no n_ast3 */
  487.     }
  488.     current_node = id_node;
  489.     /* recall that priv_types is {limited, limited_private} */
  490.     /* check_priv_decl first argument is one of MISC_TYPE_ATTRIBUTE ...*/
  491.     if (kind == symbol_private)
  492.         check_priv_decl(TA_PRIVATE, type_name);
  493.     else if (kind == symbol_limited_private)
  494.         check_priv_decl(TA_LIMITED_PRIVATE, type_name);
  495.  
  496.     else if (kind == symbol_incomplete && S_UNIT(type_name) != unit_number_now){
  497.         /* case of an incomplete type in the private part of a package, whose
  498.          * complete definition is given in the package body. Create a dummy
  499.          * symbol to which the complete definition is attached. The expander
  500.          * retrieves it and updates the symbol table of type_name accordingly.
  501.          */
  502.         d_type = sym_new(NATURE(type_name));
  503.         N_TYPE(node) = d_type;
  504.         TYPE_OF(d_type)    = TYPE_OF(type_name);
  505.         SIGNATURE(d_type) = SIGNATURE(type_name);
  506.         OVERLOADS(d_type) = OVERLOADS(type_name);
  507.         SCOPE_OF(d_type) = scope_name;
  508.         root_type(d_type) = root_type(type_name);
  509.         dcl_put(DECLARED(scope_name), newat_str(), d_type);
  510.     }
  511.     check_delayed_type(node, type_name);  /* if it has a private ancestor. */
  512. }
  513.  
  514. Symbol find_type_name(Node id_node)                 /*;find_type_name*/
  515. {
  516.     /* Create a unique  name for a type  definition, or find  the unique name
  517.      * already created, in the case of the    full declaration of an incomplete
  518.      * or  private type. 
  519.      */
  520.  
  521.     char    *id;
  522.     Symbol    incomplete, type_name, a_t;
  523.     Forset fs1;
  524.  
  525.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : find_type_name");
  526.  
  527.     id = N_VAL(id_node);
  528.  
  529.     /* Find incomplete declaration, if some was given. */
  530.  
  531.     incomplete = dcl_get(DECLARED(scope_name), id);
  532.  
  533.     if (incomplete == (Symbol)0)        /* New type declaration. */
  534.         type_name = find_new(id);
  535.     else {                                /* Previous declaration exists.*/
  536.         if (id != (char *)0 && streq(id, "any_id")) {
  537.             /* any_id identifier was inserted (by parser) */
  538.             N_UNQ(id_node) = symbol_any;
  539.             return symbol_any;
  540.         }
  541.         type_name = incomplete;
  542.         TO_XREF(incomplete);
  543.         if (!in_incp_types(TYPE_OF(incomplete))) {
  544.             errmsg_str("Invalid redeclaration of %", id, "8.3", id_node);
  545.             type_name = symbol_any;
  546.         }
  547.         if (TYPE_OF(incomplete) == symbol_incomplete) {
  548.             if(private_dependents(incomplete)) {
  549.                 FORSET(a_t = (Symbol), private_dependents(incomplete), fs1)
  550.                     if (is_access(a_t) && SCOPE_OF(a_t) == scope_name)
  551.                         /* access type is now dereferenceable.*/
  552.                         misc_type_attributes(a_t)
  553.                           = (int) misc_type_attributes(a_t) & ~TA_INCOMPLETE;
  554.                 ENDFORSET(fs1)
  555.             }
  556.         }
  557.         else {
  558.             /* Full declaration for private type. Save visible declaration in
  559.              * private decls for this package, so that full declaration can
  560.              * be installed.
  561.              */
  562.             private_decls_put((Private_declarations) private_decls(scope_name),
  563.               type_name);
  564.  
  565.             if (is_generic_type(incomplete)) {
  566.                 errmsg_l_str("Generic private type % cannot have declaration ",
  567.                   "in private part", id, "12.1", id_node);
  568.                 type_name = symbol_any;
  569.             }
  570.         }
  571.     }
  572.     N_UNQ(id_node) = type_name;
  573.     return type_name;
  574. }
  575.  
  576. static void build_type(Symbol type_name, Node opt_disc, Node type_def)
  577.                                                                 /*;build_type*/
  578. {
  579.     /* For scalar types, both generic and non-generic, this procedure  simply
  580.      * constructs the symbol table entry on the basis of the type definition.
  581.      * Enumeration    types, array  types and     derived  types     require  further
  582.      * processing. They generate additional symbol table entries for literals
  583.      * and anonymous types.
  584.      */
  585.  
  586.     Symbol    parent, desig_type;
  587.     int    l;
  588.     Node    type_indic_node;
  589.  
  590.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : build_type");
  591.  
  592.     switch (N_KIND(type_def)) {
  593.     case as_enum:
  594.         new_enum_type(type_name, type_def);
  595.         break;
  596.     case as_int_type:
  597.         new_integer_type(type_name, type_def);
  598.         break;
  599.     case as_float_type:
  600.         new_floating_type(type_name, type_def);
  601.         break;
  602.     case as_fixed_type:
  603.         new_fixed_type(type_name, type_def);
  604.         break;
  605.     case as_array_type:
  606.         new_array_type(type_name, type_def);
  607.         break;
  608.     case as_record:
  609.         record_decl(type_name, opt_disc, type_def);
  610.         break;
  611.     case as_derived_type:
  612.         derived_type(type_name, type_def);
  613.         break;
  614.     case as_access_type:
  615.         adasem(type_def);
  616.         type_indic_node = N_AST1(type_def);
  617.         desig_type = N_UNQ(type_indic_node);
  618.         if (type_name == desig_type)
  619.         errmsg_id("Invalid use of type % before its full declaration",
  620.           type_name, "3.8.1", type_indic_node);
  621.         /*??SYMBTAB(type_name) :=[na_access, type_name, desig_type];*/
  622.         NATURE(type_name)    = na_access;
  623.         TYPE_OF(type_name)   = type_name;
  624.         SIGNATURE(type_name) = (Tuple) desig_type;
  625.         new_agg_or_access_acc(type_name);
  626.         break;
  627.     }
  628.     /* The new type inherits the root type and other attributes of its parent */
  629.  
  630.     parent = TYPE_OF(type_name);
  631.  
  632.     /*root_type(type_name) = root_type(parent) ? parent;*/
  633.     if (root_type(parent) != (Symbol)0)
  634.         root_type(type_name) = root_type(parent);
  635.     else root_type(type_name) = parent;
  636.  
  637.     misc_type_attributes(type_name) = misc_type_attributes(parent);
  638.     l = private_kind(parent);
  639.     if (l != 0) {
  640.         if (misc_type_attributes(type_name) == 0)
  641.             misc_type_attributes(type_name) = l;
  642.         else 
  643.             misc_type_attributes(type_name) = 
  644.               (int) misc_type_attributes(type_name) | l;
  645.     }
  646. }
  647.  
  648. void check_delayed_type(Node node, Symbol type_mark)    /*;check_delayed_type*/
  649. {
  650.     /* called for type and subtype declarations. If the type has a sub-
  651.      * component of a private type, elaboration of the type must be delayed
  652.      * until the private ancestor has been elaborated.
  653.      */
  654.  
  655.     Symbol    pr;
  656.     Node    id_node, decl_node, ancestor_node;
  657.     int        exists;
  658.  
  659.     pr = private_ancestor(type_mark);
  660.     exists = FALSE;
  661.     if (pr != (Symbol)0) exists = TRUE;
  662.     else {
  663.         if (NATURE(type_mark) == na_subtype) {
  664.             pr = TYPE_OF(type_mark);
  665.             if (TYPE_OF(pr) == symbol_incomplete)
  666.                 exists = TRUE;
  667.         }
  668.     }
  669.     if (exists) {
  670.         id_node = N_AST1(node);
  671.         decl_node = copy_node(node);
  672.         N_KIND(node) = as_delayed_type;
  673.         ancestor_node = new_name_node(pr);
  674.         N_AST1(node) = id_node;
  675.         N_AST2(node) = ancestor_node;
  676.         N_AST3(node) = decl_node;
  677.     }
  678. }
  679.  
  680. void subtype_decl(Node node)                                 /*;subtype_decl*/
  681. {
  682.     /* Process  a subtype  declaration. id    is  the     source     id  of     the  new
  683.      * entity, and subt  is the subtype indication. If the subtype indication
  684.      * does not include a constraint, subt is either an anonymous array, or a
  685.      * subtype  indication that fucntions  as a  renaming of  a type. In that
  686.      * case the  new id  denotes the  same entity,    and does  not needs a new
  687.      * symbol table entry,    except that  for conformance  purposes it  is not
  688.      * equivalent to the original type. For now we only introduce  a new sub-
  689.      * type in the case of scalar types.
  690.      */
  691.  
  692.     Node id_node, type_indic_node, constraint;
  693.     char *id;
  694.     Symbol name, subt, parent;
  695.  
  696.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : subtype_decl");
  697.  
  698.     id_node = N_AST1(node);
  699.     type_indic_node = N_AST2(node);
  700.  
  701.     constraint = N_AST2(type_indic_node);
  702.     id = N_VAL(id_node);
  703.     adasem(type_indic_node);
  704.     subt = make_subtype(type_indic_node);
  705.  
  706.     /* The subtype may  be an  array  type which has already  been
  707.      * promoted to anonymous type. It may also be a type_mark without
  708.      * a constraint, i.e. a type name.In this case the new subtype is
  709.      * simply a  renaming of  the type, and     we set     its  unique name
  710.      * to be that type_mark.
  711.      */
  712.  
  713.     /* If the constraint is empty the subtype is simply a renaming. */
  714.     if (constraint == OPT_NODE && (!is_scalar_type(subt)
  715.       || is_generic_type(subt))) {
  716.         N_UNQ(id_node) = subt;
  717.         dcl_put(DECLARED(scope_name), id, subt);
  718.     }
  719.     else {
  720.         current_node = id_node;
  721.         name = find_new(id);
  722.         N_UNQ(id_node) = name;
  723.         SYMBTABcopy(name, subt);
  724.         if (NATURE(subt) == na_enum) {
  725.             /* Do not recopy literal map */
  726.             OVERLOADS(name) = (Set)0;
  727.         }
  728.         NATURE(name) = na_subtype;
  729.         parent = TYPE_OF(name);
  730.         root_type(name) = root_type(parent);
  731.         misc_type_attributes(name) = misc_type_attributes(parent);
  732.         check_delayed_type(node, name);
  733.  
  734.         if (is_generic_type(base_type(parent))) {
  735. #ifdef TBSL
  736.               repr_stmt := ["delayed_repr", {name}];
  737. #endif
  738.         }
  739.         else if (already_forced(base_type(parent))) {
  740.                choose_representation(name);
  741.         }
  742.         else {
  743.                not_chosen_put(base_type(parent), name);
  744.         }
  745.  
  746.     }
  747.     /* Discard the generated anonymous subtype.
  748.      * subt frome NEWTYPES;
  749.      * NEWTYPES with:= [];
  750.      */
  751. }
  752.  
  753. Symbol make_subtype(Node type_indic_node)                      /*;make_subtype*/
  754. {
  755.     Node    name_node, constraint, selector;
  756.     int        nat;
  757.     Symbol    subtype, type_mark, d_type, d_sub;
  758.     Tuple    sigtup;
  759.     char    *type_id;
  760.  
  761.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : make_subtype");
  762.  
  763.     /* Process a subtype indication.*/
  764.  
  765.     name_node = N_AST1(type_indic_node);
  766.     constraint = N_AST2(type_indic_node);
  767.  
  768.     type_mark = find_type(name_node);
  769.  
  770.     if (type_mark== symbol_any) return symbol_any;
  771.  
  772.     /* Retrieve source identifier of type, for test below.*/
  773.     if (N_KIND(name_node) == as_simple_name)
  774.         type_id = N_VAL(name_node);
  775.     else {                    /* extended name */
  776.         selector = N_AST2(name_node);
  777.         type_id = N_VAL(selector);
  778.     }
  779.  
  780.     if (in_open_scopes(base_type(type_mark)) && (! is_task_type(type_mark)
  781.       || strcmp(original_name(type_mark), type_id) == 0) ) {
  782.         /* Component of record is subtype of record type itself, or task type
  783.          * is used within its body.
  784.          */
  785.         errmsg_str("invalid use of type % within its definition or body",
  786.           type_id, "3.3, 9.1", name_node);
  787.         return type_mark;
  788.     }
  789.     else if (constraint == OPT_NODE) {
  790.         current_node = name_node;
  791.         check_incomplete(type_mark);
  792.         return type_mark;
  793.     }
  794.     else {
  795.         /* If the type is a access type, the constraint applies to the type
  796.          * being accessed. We create the corresponding subtype of it, promote
  797.          * it to an anonymous type, and return an access to it.
  798.          */
  799.  
  800.         nat = NATURE(type_mark);
  801.  
  802.         if (is_access(type_mark)) {
  803.             d_type = (Symbol) designated_type(type_mark);
  804.  
  805.             if (NATURE(d_type) == na_array) {
  806.                 d_sub = constrain_array(d_type, constraint);
  807.                 root_type(d_sub) = root_type(d_type);
  808.                 subtype = named_type(strjoin("&", newat_str()));
  809.                 /*Create  a  name for it*/
  810.                 NATURE(subtype) = na_subtype;
  811.                 TYPE_OF(subtype) = type_mark;
  812.                 sigtup = constraint_new(CONSTRAINT_ACCESS);
  813.                 sigtup[2] = (char *) d_sub;
  814.                 SIGNATURE(subtype) = sigtup;
  815.             }
  816.             else if (is_record(d_type) && NATURE(d_type) != na_subtype) {
  817.                 d_sub = constrain_record(d_type, constraint);
  818.                 root_type(d_sub) = root_type(d_type);
  819.                 subtype = named_type(strjoin("&", newat_str()));
  820.                 /*Create  a  name for it*/
  821.                 NATURE(subtype) = na_subtype;
  822.                 TYPE_OF(subtype) = type_mark;
  823.                 sigtup = constraint_new(CONSTRAINT_ACCESS);
  824.                 sigtup[2] = (char *) d_sub;
  825.                 SIGNATURE(subtype) = sigtup;
  826.             }
  827.             else {
  828.                 errmsg("Invalid constraint on access type", "3.8", constraint);
  829.                 subtype = symbol_any;
  830.             }
  831.         }
  832.  
  833.         else if (nat == na_type) {
  834.             if (is_scalar_type(type_mark))
  835.                 subtype = constrain_scalar(type_mark, constraint);
  836.             else        /* Private type with discriminants, hopefully.*/
  837.                 subtype = constrain_record(type_mark, constraint);
  838.         }
  839.         else if (nat == na_enum)
  840.             subtype = constrain_scalar(type_mark, constraint);
  841.         else if (nat == na_array)
  842.             subtype=constrain_array(type_mark, constraint);
  843.         else if (nat == na_record)
  844.             subtype = constrain_record(type_mark, constraint);
  845.         else if (nat == na_subtype) {
  846.             if (is_array(type_mark) || is_record(type_mark)) {
  847.                 errmsg(
  848.                   "Invalid subtype indication: type is already constrained",
  849.                   "3.6.1, 3.7.2", type_indic_node);
  850.                 subtype = symbol_any;
  851.             }
  852.             else
  853.                 subtype = constrain_scalar(type_mark, constraint);
  854.         }
  855.         else {
  856.             errmsg_id("Invalid type mark in subtype indication: %",
  857.               type_mark, "3.3, 3.6.1", name_node);
  858.             subtype = symbol_any;
  859.         }
  860.     }
  861.  
  862.     if (subtype != symbol_any)
  863.         root_type(subtype) = root_type(type_mark);
  864.     else
  865.         N_AST2(type_indic_node) = OPT_NODE;
  866.     return subtype;
  867. }
  868.  
  869. static void derived_type(Symbol derived_subtype,Node def_node) /*;derived_type*/
  870. {
  871.     Node type_indic_node, constraint_node;
  872.     Symbol subtype;
  873.     Symbol parent_subtype, derived_type, parent_type;
  874.     int        nat;
  875.     Tuple     constraint;
  876.  
  877.     if (cdebug2 > 3) TO_ERRFILE("derived type: ");
  878.  
  879.     type_indic_node = N_AST1(def_node);
  880.     adasem(type_indic_node);
  881.     subtype = make_subtype(type_indic_node);
  882.     constraint_node = N_AST2(type_indic_node);
  883.     if (constraint_node == OPT_NODE) {
  884.         parent_subtype = subtype;
  885.         constraint = (Tuple) SIGNATURE(parent_subtype);
  886.         /* Inherited by new type*/
  887.     }
  888.     else {
  889.         /* we use parent_subtype to designate the type mark in the subtype
  890.          * indication. The code below makes sure that the constraint of the
  891.          * parent subtype is also inherited by the derived subtype.
  892.          */
  893.         parent_subtype = TYPE_OF(subtype); /*Subtype indication.*/
  894.         constraint = (Tuple) SIGNATURE(subtype); /* Subtype indication.*/
  895.     }
  896.  
  897.     if (parent_subtype == subtype && (in_unconstrained_natures(NATURE(subtype))
  898.       /*   || (is_generic_type(subtype)) ||is_access(subtype)  */
  899.       ||in_priv_types(TYPE_OF(root_type(subtype))) ))    {
  900.         derived_type = derived_subtype;
  901.     }
  902.     else {
  903.         /* If the derived type definition includes a constraint, or if the
  904.          * old type is constrained, we first derive an anonymous type, and
  905.          * then construct a subtype of it. 
  906.          */
  907.         derived_type = named_type(strjoin(original_name(derived_subtype),
  908.           "\'base"));
  909.         { 
  910.             Tuple tmp = (Tuple) newtypes[tup_size(newtypes)];
  911.             newtypes[tup_size(newtypes)] = 
  912.                 (char *)tup_with(tmp, (char *) derived_type);
  913.  
  914.             NATURE(derived_subtype)    = na_subtype;
  915.             TYPE_OF(derived_subtype)   = derived_type;
  916.             SIGNATURE(derived_subtype) = (Tuple) constraint;
  917.             not_chosen_put(derived_type, derived_subtype);
  918.         }
  919.     }
  920.     root_type(derived_type) = derived_type;         /* initially */
  921.  
  922.     parent_type = base_type(parent_subtype);
  923.     nat = NATURE(SCOPE_OF(parent_type));
  924.     /* A derived type defined in a prackage specification cannot be used for
  925.      * further derivation until the end of its visible part. 
  926.      */
  927.     if (is_derived_type(parent_type) && (in_open_scopes(parent_type)
  928.       && (nat == na_package_spec || nat == na_generic_package_spec))
  929.       ||  TYPE_OF(parent_type) == symbol_incomplete
  930.       || private_ancestor(parent_type) != (Symbol)0 ) {
  931.         errmsg_id("premature derivation of derived or private type %",
  932.           parent_type, "3.4, 7.4.1", type_indic_node);
  933.     }
  934.     build_derived_type(parent_subtype, derived_type , type_indic_node);
  935. }
  936.  
  937. static void build_derived_type(Symbol parent_subtype, Symbol derived_type,
  938.   Node node)                                        /*;build_derived_type */ 
  939. {
  940.     /* build symbol table entry for derived type, after processing constraint.
  941.      * called from previous procedure, and from update_one_entry, to handle
  942.      * types derived from generic formal types.
  943.      */
  944.  
  945.     Symbol parent_type, parent_scope;
  946.     Symbol comp;
  947.     int    exists, nat1, i, l;
  948.     Forset    fs;
  949.     Symbol new_lit_name, lit_sym, nam;
  950.     Symbol    d1, d2;
  951.     char    *lit_id;
  952.     Tuple new_sig, lit_map, dl1, dl2, array_info;
  953.     Declaredmap    parent_dcl;
  954.  
  955.     parent_type = base_type(parent_subtype);
  956.     nat1 = NATURE(parent_type);
  957.  
  958.     switch (nat1 = NATURE(parent_type)) {
  959.     case na_type:
  960.         NATURE(derived_type)    = na_type;
  961.         TYPE_OF(derived_type)   = parent_type;
  962.         SIGNATURE(derived_type) = SIGNATURE(parent_type);
  963.         break;
  964.     case na_array:
  965.         array_info = SIGNATURE(parent_type);
  966.         /* The following code is very similar to new_unconstrained_array but
  967.          * avoids building a tree fragment for the array and then unpacking it
  968.          */
  969.         comp = (Symbol) array_info[2];
  970.         NATURE(derived_type)    = na_array;
  971.         TYPE_OF(derived_type)   = derived_type;
  972.         SIGNATURE(derived_type) = array_info;
  973.         /* Mark the type as limited if the component type is.*/
  974.         misc_type_attributes(derived_type) = private_kind(comp);
  975.         /* For each unconstrained array type, we introduce an instance of the
  976.          * 'aggregate' pseudo-operator for that array.
  977.          */
  978.         new_agg_or_access_agg(derived_type);
  979.         break;
  980.  
  981.     /* A derived record type has the same fields and types as the parent.
  982.      * All we need to do is introduce an aggregate under the new type mark.
  983.      * The declaration may have a discriminant part, in which case they
  984.      * must conform to the discriminants of the parent type. We assume that
  985.      * the discriminant names, types, and default values must be the same.
  986.      */
  987.     case na_record:
  988.         if (is_record(derived_type)) {
  989.             dl1 = (Tuple) discriminant_list(derived_type);
  990.             dl2 = (Tuple) discriminant_list(parent_type);
  991.             exists = FALSE;
  992.             if (tup_size(dl1) != tup_size(dl2)) {
  993.                 exists = TRUE;
  994.                 if (! exists) {
  995.                     for (i = 1; i <= tup_size(dl1); i++) {
  996.                         d1 = (Symbol) dl1[i]; 
  997.                         d2 = (Symbol) dl2[i];
  998.                         if (TYPE_OF(d1) != TYPE_OF(d2)
  999.                              || default_expr(d1) != default_expr(d2) /*$tree equ?*/
  1000.                           || strcmp(original_name(d1),original_name(d2)) != 0) {
  1001.                             exists = TRUE;
  1002.                             break;
  1003.                         }
  1004.                     }
  1005.                 }
  1006.                 if (exists) {
  1007.                     errmsg("discriminant mismatch in derived type declaration",
  1008.                       "3.8", node);
  1009.                 }
  1010.             }
  1011.         }
  1012.         NATURE(derived_type) = na_record;
  1013.         TYPE_OF(derived_type) = derived_type;
  1014. #ifdef TBSL
  1015.         -- is it necessary to 'copy' SIGNATURE and/or DECLARED. 
  1016.            -- check this. For now, do copy for DECLARED    ds 6-jan-85
  1017. #endif
  1018.         SIGNATURE(derived_type) = record_declarations(parent_type);
  1019.         DECLARED(derived_type) = DECLARED(parent_type);
  1020.         if (DECLARED(parent_type) != (Declaredmap) 0)
  1021.             DECLARED(derived_type) = dcl_copy(DECLARED(parent_type));
  1022.         new_agg_or_access_agg(derived_type);
  1023.         break;
  1024.     /* A derived enumeration type has the literals of its parent, but these
  1025.         * are marked as derived, to enforce the overloading rules.
  1026.         */
  1027.     case na_enum:
  1028.         lit_map = (Tuple) literal_map(parent_type);
  1029.         parent_scope = SCOPE_OF(parent_type);
  1030.         parent_dcl = DECLARED(parent_scope);
  1031.         /* Recall that literal map as tuple for now */
  1032.         for (i = 1; i <= tup_size(lit_map); i+=2) {
  1033.             lit_id = lit_map[i];
  1034.             /* retrieve unique_name of literal */
  1035.             lit_sym = dcl_get(parent_dcl, lit_id);
  1036.             FORSET(nam=(Symbol), OVERLOADS(lit_sym), fs)
  1037.                 if (TYPE_OF(nam) == parent_type)
  1038.                     break;
  1039.             ENDFORSET(fs)
  1040.             new_lit_name =
  1041.               chain_overloads(lit_id, na_literal, derived_type,
  1042.               tup_new(0), nam, OPT_NODE);
  1043.             ALIAS(new_lit_name) = nam; /* unique name of parent */
  1044.         }
  1045.         new_sig = SIGNATURE(parent_type);
  1046.         NATURE(derived_type)    = na_enum;
  1047.         TYPE_OF(derived_type)   = derived_type;
  1048.         SIGNATURE(derived_type) = new_sig;
  1049.         OVERLOADS(derived_type) = (Set) lit_map;
  1050.         break;
  1051.     case na_access:
  1052.         NATURE(derived_type)    = na_access;
  1053.         TYPE_OF(derived_type)   = derived_type;
  1054.         SIGNATURE(derived_type) = SIGNATURE(parent_type);
  1055.         new_agg_or_access_acc(derived_type);
  1056.         break;
  1057.     case na_task_type:
  1058.     case na_task_type_spec:
  1059.         SYMBTABcopy(derived_type, parent_type);
  1060.         NATURE(derived_type)   = na_task_type; /*even if parent is spec*/
  1061.         DECLARED(derived_type) = DECLARED(parent_type);
  1062.         break;
  1063.     default:    /*previous error, unsupported numeric type, etc. */
  1064.         break;
  1065.     }
  1066.  
  1067.     root_type(derived_type) = root_type(parent_type);
  1068.  
  1069.     derive_subprograms(parent_subtype, derived_type);
  1070.     if (nat1 != na_enum) {
  1071.         l = private_kind(parent_type);
  1072.         misc_type_attributes(derived_type) = l;
  1073.         /* otherwise the attribute is the literal map*/
  1074.     }
  1075. inherit_representation_info(derived_type, parent_type);
  1076. }
  1077.  
  1078. static int in_unconstrained_natures(int x)        /*;in_unconstrained_natures*/
  1079. {
  1080.     /* equiv to x in unconstrained_natures ... */
  1081.     return x == na_enum || x == na_array || x == na_record || x == na_access
  1082.       || x == na_task_type || x == na_task_type_spec;
  1083. }
  1084.  
  1085. static int is_derived_type(Symbol mark)  /*;is_derived_type*/
  1086. {
  1087.     return (base_type(mark) != root_type(mark) && (! is_generic_type(mark)));
  1088.  
  1089.     /* Incomplete for composite types.*/
  1090. }
  1091.  
  1092. static void derive_subprograms(Symbol parent_subtype, Symbol derived_type)
  1093.                                                         /*;derive_subprograms*/
  1094. {
  1095.     /* In order to derive the subprograms of the parent type, the parent type
  1096.      * must be defined in  the visible part of a package, and the derivation
  1097.      * must take place after the end of this visible part.
  1098.      *
  1099.      * We introduce in the symbol table the new subprograms with the derived
  1100.      * signature, but do not emit code for them. We produce instead a
  1101.      * mapping from the inherited subprogram to its ancestor, and replace
  1102.      * the name at the point of call, in macro-like fashion.
  1103.      *
  1104.      * If the  parent type is a private type whose full declaration is
  1105.      * a first-named subtype, then  its base type is declared in the private
  1106.      * part. Then if the derivation takes place in the private part itself,
  1107.      * the parent type does not appear in the visible part of the package,
  1108.      * but the parent subtype does. This anomaly must be checked for explicitly.
  1109.      * checked for separately.
  1110.      */
  1111.  
  1112.     Symbol    parent_scope, sym, obj;
  1113.     Symbol  parent_type;
  1114.     int    is_visible_type, nat;
  1115.     char    *str, *id;
  1116.     Fordeclared    div;
  1117.     Declaredmap decmap;
  1118.  
  1119.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : derive_subprograms");
  1120.  
  1121.     parent_type  = base_type(parent_subtype);
  1122.     parent_scope = SCOPE_OF(parent_type);
  1123.     nat          = NATURE(parent_scope);
  1124.     is_visible_type = FALSE;
  1125.     decmap = (Declaredmap)(DECLARED(parent_scope));
  1126.  
  1127.     if ((nat == na_package || nat == na_package_spec)
  1128.       && !in_open_scopes(parent_scope)) {
  1129.         /* common case: derivation outside of package.*/
  1130.         FORVISIBLE(str, sym, decmap, div)
  1131.             if (sym == parent_type) {
  1132.                 is_visible_type = TRUE;
  1133.                 break;
  1134.             }
  1135.         ENDFORVISIBLE(div)
  1136.     }
  1137.     else if (nat == na_private_part
  1138.       /* which is a currently open scope. */
  1139.       || (nat == na_package && in_open_scopes(parent_scope))) {
  1140.         /* verify that parent SUBtype is declared in visible part. */
  1141.         FORVISIBLE(str, sym, decmap, div)
  1142.             if (sym == parent_subtype) {
  1143.                 is_visible_type = TRUE;
  1144.                 break;
  1145.             }
  1146.         ENDFORVISIBLE(div)
  1147.     }
  1148.     if (is_visible_type) {    /* calculate inheritance.*/
  1149.         if (parent_scope == scope_name) {
  1150.             /* Derivation is in private part of package that declares the
  1151.              * parent. Copy declared map to insure that domain of iteration of
  1152.              * following loop is not modified by insertions of derived
  1153.              * subprograms.
  1154.              */
  1155.             decmap = dcl_copy(decmap);
  1156.         }
  1157.         FORVISIBLE(id, obj, decmap, div)
  1158.             nat = NATURE(obj);
  1159.             if((nat == na_procedure || nat == na_procedure_spec
  1160.               || nat == na_function  || nat == na_function_spec)
  1161.               && !is_derived_subprogram(obj))
  1162.                 derive1_subprogram(obj, parent_type, derived_type, obj);
  1163.         ENDFORVISIBLE(div)
  1164.     }
  1165.     if (is_derived_type(parent_type) && parent_scope != symbol_standard0) {
  1166.         /* If the original type is a derived type, its derived subprograms
  1167.          * are further derived. If such exist, they are aliased subprograms
  1168.          * declared in the same scope as the parent type.
  1169.          */
  1170.         if ( !is_visible_type && parent_scope == scope_name)
  1171.             decmap = dcl_copy(decmap);
  1172.  
  1173.         FORDECLARED(id, obj, decmap, div)
  1174.             nat = NATURE(obj);
  1175.             if ((nat == na_procedure || nat == na_procedure_spec
  1176.               || nat == na_function || nat == na_function_spec)
  1177.               && is_derived_subprogram(obj)
  1178.               && ( ! is_visible_type || ! hidden_derived(obj, parent_scope) ))
  1179.                 derive1_subprogram(obj, parent_type, derived_type, ALIAS(obj));
  1180.         ENDFORDECLARED(div)
  1181.     }
  1182. }
  1183.  
  1184. static void derive1_subprogram(Symbol obj, Symbol parent_type,
  1185.   Symbol derived_type, Symbol parent_subp)                /*;derive1_subprogram*/
  1186. {
  1187.     /* obj is a subprogram declared in the same scope as parent_type. If
  1188.      * some type in its profile is compatible with parent_type, produce
  1189.      * a derived subprogram by replacing the parent_type with the derived
  1190.      * one, and introduce a subprogram declaration with this new profile.
  1191.      * The parent subprogram is either obj itself, or ALIAS(obj) if obj is
  1192.      * already a derived subprogram.
  1193.      */
  1194.     Symbol    new_typ, formal, tf, dx, new_proc;
  1195.     Symbol neq, new_neq;
  1196.     char    *id;
  1197.     int    is_new, nat;
  1198.     Fortup    ft1;
  1199.     Tuple    new_sig, t;
  1200.  
  1201.     new_sig = tup_new(0);
  1202.     new_typ = TYPE_OF(obj);
  1203.     is_new = FALSE;
  1204.  
  1205.     FORTUP(formal =(Symbol) , SIGNATURE(obj), ft1);
  1206.         nat = NATURE(formal);
  1207.         id = original_name(formal);
  1208.         tf = TYPE_OF(formal);
  1209.         dx = (Symbol) default_expr(formal);
  1210.  
  1211.         if (compatible_types(tf, parent_type)) {
  1212.             tf = derived_type;
  1213.             is_new = TRUE;
  1214.         }
  1215.         t = tup_new(4);
  1216.         t[1] =  strjoin(id, "");
  1217.         t[2] = (char *) nat;
  1218.         t[3] = (char *) tf;
  1219.         t[4] = (char *) dx;
  1220.         new_sig = tup_with(new_sig, (char *) t);
  1221.     ENDFORTUP(ft1);
  1222.  
  1223.     if (compatible_types(new_typ, parent_type) ) {
  1224.         new_typ = derived_type;
  1225.         is_new  = TRUE;
  1226.     }
  1227.  
  1228.     if (is_new) {
  1229.         /* subprogram is derived. Insert it in current scope, with
  1230.          * the new signature, and recall its lineage.
  1231.          * Its nature is a subprogram, not a spec, because no body
  1232.          * will be defined for it.
  1233.          */
  1234.         nat = NATURE(obj) == na_procedure_spec ? na_procedure : na_function;
  1235.         id = original_name(obj);
  1236.  
  1237.         /* If the subprogram is /=, it will be automatically derived when
  1238.          * te corresponding equality operator is.
  1239.          */
  1240.         if (streq(id, "/=")) return;
  1241.         /*new_proc = chain_overloads(id, [nat,new_typ, new_sig, parent_subp]);*/
  1242.         new_proc = chain_overloads(id, nat, new_typ, new_sig, parent_subp,
  1243.           OPT_NODE);
  1244.         if (new_proc != (Symbol)0) { /* There is no explicit sub-*/
  1245.             ALIAS(new_proc) = parent_subp;       /* program with that name.*/
  1246.             if (streq(id, "=")) {
  1247.                 /* mark the parent of the corresponding inequality. */
  1248.                 neq            = find_neq(parent_subp);
  1249.                 new_neq        = find_neq(new_proc);
  1250.                 ALIAS(new_neq) = neq;
  1251.             }
  1252.         }
  1253.     }
  1254. }
  1255.  
  1256. static int hidden_derived(Symbol subp, Symbol parent_scope)    /*;hidden_derived */
  1257. {
  1258.     /* Determine whether a derived subprogram is hidden by an explicit 
  1259.      * declaration in the visible part of a package.
  1260.      * If the derivation occurs within the private part of the package,  or
  1261.      * within its body, the set of subprograms that may hide the derived one is
  1262.      * the overloads set of the private declarations of the symbol. Otherwise
  1263.      * it is  the overloads set of the visible symbol.
  1264.      */
  1265.  
  1266.     Symbol seen, s;
  1267.     Forset fs1;
  1268.     Symbol obj;
  1269.  
  1270.     seen = dcl_get_vis(DECLARED(parent_scope), ORIG_NAME(subp));
  1271.  
  1272.     if (seen == (Symbol)0) return FALSE;
  1273.  
  1274.     else if ( in_open_scopes(parent_scope)
  1275.       && NATURE(parent_scope) != na_package_spec 
  1276.       && (s = private_decls_get((Private_declarations)
  1277.       private_decls(parent_scope), seen)) != (Symbol)0 )
  1278.         seen = s;
  1279.  
  1280.     if (!can_overload(seen)) return FALSE;
  1281.  
  1282.     FORSET(obj=(Symbol), OVERLOADS(seen), fs1)
  1283.         if ( obj != subp && same_signature(obj, subp)
  1284.           && base_type(TYPE_OF(subp)) == base_type(TYPE_OF(obj)))
  1285.             return TRUE;
  1286.     ENDFORSET(fs1);
  1287.     return FALSE;
  1288. }
  1289.  
  1290. static Symbol find_neq(Symbol eq_name)                            /*;find_new*/
  1291. {
  1292.     /* find implicitly defined inequality corresponding to an equality operator,
  1293.      * either explicitly defined or derived, by iterating over definitions of /=
  1294.      * in the scope, that have the same signature as the given equality.
  1295.      */
  1296.  
  1297.     Forset fs1;
  1298.     Symbol neq;
  1299.  
  1300.     FORSET(neq=(Symbol), OVERLOADS(dcl_get(DECLARED(SCOPE_OF(eq_name)), "/=")),
  1301.       fs1)
  1302.         if (same_signature(neq, eq_name)) {
  1303.         return neq;
  1304.     }
  1305.     ENDFORSET(fs1)
  1306.     chaos("can't find inequality operator in scope");
  1307.     return (Symbol)0;
  1308. }
  1309.  
  1310. int is_derived_subprogram(Symbol name)                 /*;is_derived_subprogram*/
  1311. {
  1312.     Symbol s;
  1313.  
  1314.     s = ALIAS(name);
  1315.     return (s != (Symbol)0 && streq(ORIG_NAME(s) , ORIG_NAME(name)) );
  1316. }
  1317.  
  1318. static void new_enum_type(Symbol type_name, Node def_node)  /*;new_enum_type*/
  1319. {
  1320.     Tuple c;
  1321.     Tuple    lit_map, literals_list;
  1322.     int    i;
  1323.     Node    lo, hi, tmpnode;
  1324.  
  1325.     adasem(def_node);
  1326.     literals_list = N_LIST(def_node);
  1327.     lit_map = tup_new(2*tup_size(literals_list));
  1328.  
  1329.     for (i = 1; i <= tup_size(literals_list); i++) {
  1330.         /* insert each literal in symbol table, as an overloadable identifier
  1331.          * Each enumeration type is mapped  into a sequence    of integers, and
  1332.          * each literal is defined as a constant with integer value.
  1333.          */
  1334.         tmpnode = (Node)(literals_list[i]);
  1335.         chain_overloads(N_VAL(tmpnode), na_literal, type_name, tup_new(0),
  1336.           (Symbol)0, OPT_NODE);
  1337.         /*    lit_map(N_VAL(literals_list(i))) := i-1;*/
  1338.         /*    lit_map[2*i-1] = (char *) N_VAL((Node)(literals_list[i]));*/
  1339.         lit_map[2*i-1] = N_VAL(tmpnode);
  1340.         lit_map[2*i] = (char *) i-1;
  1341.     }
  1342.     lo = new_ivalue_node(int_const(0), type_name);
  1343.     hi = new_ivalue_node(int_const(tup_size(literals_list) - 1), type_name);
  1344. #ifdef TBSN
  1345.     -- this should no longer be necessary, as they are saved in
  1346.     -- collect_unit_nodes
  1347.     /* Attach nodes of bounds to AST, to insure saving for separate 
  1348.      * compilation.
  1349.      */
  1350.     /*N_LIST(def_node) +:= [lo, hi];*/
  1351.     N_LIST(def_node) = tup_with(N_LIST(def_node), (char *) lo);
  1352.     N_LIST(def_node) = tup_with(N_LIST(def_node), (char *) hi);
  1353. #endif
  1354.     /*SYMBTAB(type_name) := [na_enum, type_name, ['range', lo, hi], lit_map];*/
  1355.     NATURE(type_name) = na_enum;
  1356.     TYPE_OF(type_name) = type_name;
  1357.     c = constraint_new(CONSTRAINT_RANGE);
  1358.     numeric_constraint_low(c) = (char *) lo;
  1359.     numeric_constraint_high(c) = (char *) hi;
  1360.     SIGNATURE(type_name) = (Tuple) c;
  1361.     OVERLOADS(type_name) = (Set) lit_map;
  1362.     initialize_representation_info(type_name, TAG_ENUM);
  1363. }
  1364.  
  1365. static void new_integer_type(Symbol type_name, Node def_node)
  1366.                                                         /*;new_integer_type*/
  1367. {
  1368.     /* Create a new integer, and apply the constraint to obtain subtype of it.*/
  1369.  
  1370.     Symbol    newtype;
  1371.     Node constraint_node, lo, hi;
  1372.     Tuple    c;
  1373.  
  1374.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : new_integer_type");
  1375.  
  1376.     constraint_node = N_AST1(def_node);
  1377.     adasem(constraint_node);
  1378.  
  1379.     newtype = anonymous_type();
  1380.     SYMBTABcopy(newtype, symbol_integer);
  1381.     root_type(newtype) = symbol_integer;
  1382.     inherit_representation_info(newtype, symbol_integer);
  1383.  
  1384.     /* get bounds of range : lo, hi.*/
  1385.     lo = N_AST1(constraint_node);
  1386.     hi = N_AST2(constraint_node);
  1387.  
  1388.     check_type_i(lo);
  1389.     check_type_i(hi);
  1390.     specialize(lo, symbol_integer);
  1391.     specialize(hi, symbol_integer);
  1392.  
  1393.     if (!(is_static_expr(lo)) || (! (is_static_expr(hi)))) {
  1394.         errmsg("Bounds in an integer type definition must be static",
  1395.           "3.5.4", constraint_node);
  1396.     }
  1397.     else if (root_type(N_TYPE(lo)) != symbol_integer
  1398.       || root_type(N_TYPE(hi)) != symbol_integer)     {
  1399.         /* these are tests on the root type of each node.*/
  1400.         errmsg_l("Bounds in an integer type definition must be of some ",
  1401.           "integer type", "3.5.4", constraint_node);
  1402.     }
  1403.     NATURE(type_name) = na_subtype;
  1404.     TYPE_OF(type_name) = newtype;
  1405.     c = constraint_new(CONSTRAINT_RANGE);
  1406.     numeric_constraint_low(c) = (char *) lo;
  1407.     numeric_constraint_high(c) = (char *) hi;
  1408.     SIGNATURE(type_name) = (Tuple) c;
  1409.     not_chosen_put(newtype, type_name);
  1410. }
  1411.  
  1412. static void new_floating_type(Symbol type_name, Node def_node)
  1413.                                                         /*;new_floating_type*/
  1414. {
  1415.     Node    float_pt_node, precision_node, opt_range, lo, hi;
  1416.     Symbol    newtype, p_type;
  1417.     Symbol    anonymous_type();
  1418.     int    digits;
  1419.     Tuple constraint;
  1420.     Const    con;
  1421.  
  1422.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : new_floating_type");
  1423.  
  1424.     /* Process a floating point declaration.*/
  1425.     float_pt_node = N_AST1(def_node);
  1426.     adasem(float_pt_node);
  1427.  
  1428.     precision_node = N_AST1(float_pt_node);
  1429.     opt_range = N_AST2(float_pt_node);
  1430.  
  1431.     /* The range constraint is optional. If absent, the range is that of
  1432.      * the parent type. If present,     the bounds  need not be of the same
  1433.      * type, but of some real type, and static. Their resolution is done
  1434.      * in procedure real-bound.
  1435.      */
  1436.  
  1437.     newtype = anonymous_type();
  1438.     SYMBTABcopy(newtype, symbol_float);
  1439.     root_type(newtype) = symbol_float;
  1440.     SYMBTABcopy(type_name, newtype);       /* by default.*/
  1441.     check_type_i(precision_node);
  1442.     p_type = N_TYPE(precision_node);
  1443.  
  1444.     if (p_type == symbol_any)  /* Type error.*/
  1445.         return;
  1446.     else if (! is_static_expr(precision_node)) {
  1447.         errmsg("Expect static expression for digits", "3.5.7", precision_node);
  1448.         return;
  1449.     }
  1450.  
  1451.     if (p_type == symbol_universal_integer)
  1452.         specialize(precision_node, symbol_integer);
  1453.     else if (root_type(p_type) != symbol_integer) {
  1454.         errmsg("Expect integer expression for DIGITS", "3.5.7", precision_node);
  1455.         return;
  1456.     }
  1457.  
  1458.     eval_static(precision_node);
  1459.     con = (Const) N_VAL(precision_node);
  1460.     digits = con->const_value.const_int;
  1461.     if (digits < 1) {
  1462.         errmsg("Invalid digits value in real type declaration", "3.5.7",
  1463.           precision_node);
  1464.         return;
  1465.     }
  1466.     else if (digits > ADA_REAL_DIGITS) {
  1467.         errmsg("Precision not supported by implementation", "none",
  1468.           precision_node);
  1469.         return;
  1470.     }
  1471.  
  1472.     inherit_representation_info(newtype, symbol_float);
  1473.     if (opt_range == OPT_NODE) {        /* Use system FLOAT.*/
  1474.         /* constraint = SIGNATURE(symbol_float);
  1475.          * constraint(4) = precision_node;    
  1476.          */
  1477.         Tuple sig = (Tuple) SIGNATURE(symbol_float);
  1478.         constraint = constraint_new(CONSTRAINT_DIGITS);
  1479.         numeric_constraint_low(constraint) = numeric_constraint_low(sig);
  1480.         numeric_constraint_high(constraint) = numeric_constraint_high(sig);
  1481.         numeric_constraint_digits(constraint) = (char *) precision_node;
  1482.     }
  1483.     else {
  1484.         lo = N_AST1(opt_range);
  1485.         hi = N_AST2(opt_range);
  1486.  
  1487.         if (real_bound(lo, symbol_float) == OPT_NODE) return;
  1488.         if (real_bound(hi, symbol_float) == OPT_NODE) return;
  1489.  
  1490.         constraint = constraint_new(CONSTRAINT_DIGITS);
  1491.         numeric_constraint_low(constraint) = (char *) lo;
  1492.         numeric_constraint_high(constraint) = (char *) hi;
  1493.         numeric_constraint_digits(constraint) = (char *) precision_node;
  1494.     }
  1495.  
  1496.     NATURE(type_name) = na_subtype;
  1497.     TYPE_OF(type_name) = newtype;
  1498.     SIGNATURE(type_name) = (Tuple) constraint;
  1499.     not_chosen_put(newtype, type_name);
  1500. }
  1501.  
  1502. static void new_fixed_type(Symbol type_name, Node def_node)  /*;new_fixed_type*/
  1503. {
  1504.     Node    lo, hi, fixed_pt_node, precision_node, opt_range, small_node;
  1505.     Symbol    r, p_type, anon_type;
  1506.     Tuple constraint;
  1507.     Rational small_val;
  1508.     Rational lo_val, hi_val, anon_lo_val, anon_hi_val;
  1509.     int    power_conv;
  1510.  
  1511.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : new_fixed_type");
  1512.  
  1513.     /* Process a fixed point declaration. Similar to floating case.*/
  1514.  
  1515.     fixed_pt_node = N_AST1(def_node);
  1516.     adasem(fixed_pt_node);
  1517.  
  1518.     precision_node = N_AST1(fixed_pt_node);
  1519.     opt_range = N_AST2(fixed_pt_node);
  1520.  
  1521.     anon_type = anonymous_type();
  1522.     NATURE(anon_type)  = na_type;
  1523.     TYPE_OF(anon_type) = anon_type;
  1524.     root_type(anon_type) = symbol_dfixed;
  1525.  
  1526.     NATURE(type_name)    = na_subtype;
  1527.     TYPE_OF(type_name)   = anon_type;
  1528. #ifdef TBSL
  1529.     -- see if tup_copy needed for SIGNATURE assignments below
  1530.         ds 6-jan-85
  1531. #endif
  1532.     SIGNATURE(anon_type) = SIGNATURE(symbol_dfixed);
  1533.     SIGNATURE(type_name) = SIGNATURE(symbol_dfixed);
  1534.  
  1535.     initialize_representation_info(anon_type, TAG_FIXED);
  1536.     not_chosen_put(anon_type, type_name);
  1537.     check_type_r(precision_node);
  1538.     p_type = N_TYPE(precision_node);
  1539.  
  1540.     if (N_TYPE(precision_node) == symbol_any)  /* Type error.*/
  1541.         return;
  1542.     else if (! is_static_expr(precision_node)) {
  1543.         errmsg("Expect static expression for delta", "3.5.7", precision_node);
  1544.         return;
  1545.     }
  1546.  
  1547.     r = root_type(p_type);
  1548.     if (is_fixed_type(r) || r == symbol_universal_real);
  1549.     else if (r == symbol_float)
  1550.         N_VAL(precision_node) = (char *) rat_const(rat_frr
  1551.           (REALV((Const)N_VAL(precision_node))));
  1552.     else {
  1553.         errmsg("Expression for delta must be of some real type", "3.5.9",
  1554.           precision_node);
  1555.         return;
  1556.     }
  1557.  
  1558.     if (opt_range == OPT_NODE) {
  1559.         errmsg("Missing range in Fixed type declaration", "3.5.9",
  1560.           fixed_pt_node);
  1561.         return;
  1562.     }
  1563.     else {
  1564.         lo = N_AST1(opt_range);
  1565.         hi = N_AST2(opt_range);
  1566.         if (real_bound(lo, symbol_dfixed) == OPT_NODE)return;
  1567.         if (real_bound(hi, symbol_dfixed) == OPT_NODE) return;
  1568.  
  1569.         N_TYPE(lo) = N_TYPE(hi) = anon_type;
  1570.  
  1571.         lo_val = RATV((Const)N_VAL(lo));
  1572.         hi_val = RATV((Const)N_VAL(hi));
  1573.         /* The constraint may eventually carry a rep.spec. for 'SMALL. Its
  1574.          * absence is marked by OPT_NODE.
  1575.          */
  1576.         /*constraint := ['delta', lo, hi, precision_node, OPT_NODE];*/
  1577.         constraint = constraint_new(CONSTRAINT_DELTA);
  1578.         numeric_constraint_low(constraint)   = (char *) lo;
  1579.         numeric_constraint_high(constraint)  = (char *) hi;
  1580.         numeric_constraint_delta(constraint) = (char *) precision_node;
  1581.         numeric_constraint_small(constraint) = (char *) OPT_NODE;
  1582.         power_conv = power_of_2((Const) N_VAL(precision_node));
  1583.         small_val = power_of_2_small;
  1584.         if (power_conv) { /* if cannot convert */
  1585.             errmsg("Precision not supported by implementation.",
  1586.               "Appendix F", fixed_pt_node);
  1587.         }
  1588.         else {
  1589.             small_node = new_ivalue_node(rat_const(small_val),
  1590.               get_type(precision_node));
  1591.             numeric_constraint_small(constraint) = (char *) small_node;
  1592.         }
  1593.     }
  1594.     SIGNATURE(type_name) = (Tuple) constraint;
  1595.     /* compute signature for anonymous type */
  1596.     constraint = tup_copy(constraint);
  1597.     /* now compute proper lower and upper bounds for anonymous type */
  1598.     /* N_VAL(l_node) := [(MIN_INT+1)*num(small), den(small)]; */
  1599.     anon_lo_val = rat_fri(int_mul(int_add(ADA_MIN_FIXED_MP, int_fri(1)),
  1600.       num(small_val)), den(small_val));
  1601.  
  1602.     /* N_VAL(u_node) := [MAX_INT*num(small), den(small)]; */
  1603.     anon_hi_val = rat_fri( int_mul(ADA_MAX_FIXED_MP,
  1604.       num(small_val)), den(small_val));
  1605.  
  1606.     numeric_constraint_low(constraint)  = 
  1607.       (char *)new_ivalue_node(rat_const(anon_lo_val), type_name);
  1608.  
  1609.     numeric_constraint_high(constraint) = 
  1610.       (char *)new_ivalue_node(rat_const(anon_hi_val), type_name);
  1611.  
  1612.     SIGNATURE(anon_type) = (Tuple) constraint;
  1613.  
  1614.     if (rat_geq(anon_hi_val, hi_val));   /* type is representable */
  1615.     else if (rat_eql(rat_sub(hi_val, anon_hi_val), small_val))
  1616.         /* given bound is 'small away from model number. Set 'last of the type
  1617.          * to be largest model number.
  1618.          */
  1619.         N_VAL(hi) = (char *)rat_const(anon_hi_val);
  1620.     else errmsg("fixed type definition requires more than MAX_MANTISSA bits",
  1621.       "Appendix F", fixed_pt_node);
  1622.  
  1623.     if (rat_leq(anon_lo_val, lo_val));
  1624.     else if (rat_eql(rat_sub(anon_lo_val, lo_val), small_val))
  1625.         /* Set 'first of the type to be smallest model number.  */
  1626.         N_VAL(lo) = (char *)rat_const(anon_lo_val);
  1627.     else errmsg("fixed type definition requires more than MAX_MANTISSA bits",
  1628.       "Appendix F", fixed_pt_node);
  1629. }
  1630.  
  1631. static Node real_bound(Node bound, Symbol kind)                  /*;real_bound*/
  1632. {
  1633.     /* Verify that the bound of a range constraint in a real type definition
  1634.      * is a real type, and convert it to or from universal when needed.
  1635.      */
  1636.  
  1637.     Symbol    b_type, r_type;
  1638.  
  1639.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : real_bound");
  1640.  
  1641.     check_type_r(bound);
  1642.     b_type = N_TYPE(bound);
  1643. /*// Is following return value correct? Added to get code to compile with CC*/
  1644.     if (b_type == symbol_any) return OPT_NODE;
  1645.     r_type = root_type(b_type);
  1646.  
  1647.     if (! is_static_expr(bound)) {
  1648.         errmsg("Bound in range constraint of type definition must be static",
  1649.           "3.5.7, 3.5.9", bound);
  1650.         return OPT_NODE;
  1651.     }
  1652.     else if (kind == symbol_float)  /* Fixed or universal bound.*/
  1653.         specialize(bound, symbol_float);
  1654.     else if (is_fixed_type(kind)) {
  1655.         if (r_type == symbol_float) {
  1656.             N_VAL(bound) =
  1657.               (char *) rat_const(rat_frr(REALV((Const)N_VAL(bound))));
  1658.             N_TYPE(bound) = symbol_dfixed;
  1659.         }
  1660.     }
  1661.     return bound;
  1662. }
  1663.  
  1664. static Symbol constrain_scalar(Symbol type_mark, Node constraint)
  1665.                                                         /*;constrain_scalar*/
  1666. {
  1667.     /* Constrain a discrete type or a real type */
  1668.  
  1669.     int constr;
  1670.     Symbol    base_mark, bt, kind;
  1671.     Node lo, hi, precision, range_constraint, attr_node, base_precision;
  1672.     int constr_type, digits;
  1673.     Tuple new_c, old_c;
  1674.     Symbol    typ;
  1675.     Const    delta;
  1676.     Rational    rdelta;
  1677.  
  1678.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : constrain_scalar");
  1679.  
  1680.     constr_type = N_KIND(constraint);
  1681.     base_mark = (Symbol) base_type(type_mark);
  1682.     old_c = SIGNATURE(type_mark);
  1683.  
  1684.     if (constr_type == as_range) {
  1685.         /* In this case, the bounds expressions have not been
  1686.          * type-checked yet. Do it now that the desired base
  1687.          * type is known.
  1688.          */
  1689.         bt = root_type(type_mark);
  1690.         if (! is_scalar_type(bt)) {
  1691.             errmsg("Invalid RANGE constraint for type", "3.3, 3.6.1",
  1692.               constraint);
  1693.             return symbol_any;
  1694.         }
  1695.         lo = N_AST1(constraint);
  1696.         hi = N_AST2(constraint);
  1697.         check_type(base_mark, lo);
  1698.         check_type(base_mark, hi);
  1699.  
  1700.         constr = (int) numeric_constraint_kind(old_c);
  1701.         new_c = constraint_new(constr);
  1702.         numeric_constraint_low(new_c)  = (char *) lo;
  1703.         numeric_constraint_high(new_c) = (char *) hi;
  1704.  
  1705.         if (bt == symbol_float) {
  1706.             /* use digits specified for parent type  */
  1707.             numeric_constraint_digits(new_c) = numeric_constraint_digits(old_c);
  1708.         }
  1709.         else if (is_fixed_type(bt)) {
  1710.             numeric_constraint_delta(new_c) = numeric_constraint_delta(old_c);
  1711.             numeric_constraint_small(new_c) = numeric_constraint_small(old_c);
  1712.         }
  1713.     }
  1714.     else if (constr_type == as_digits  || constr_type== as_delta)     {
  1715.         kind = constr_type == as_digits ? symbol_float: symbol_dfixed;
  1716.         if (root_type(type_mark) != kind ) {
  1717.             errmsg("Invalid constraint for type", "3.3", constraint);
  1718.             return symbol_any;
  1719.         }
  1720.         /* if (is_generic_type(base_mark)) {
  1721.          *       errmsg("accurracy constraint cannot depend on a generic type",
  1722.          *       "12.1", constraint);
  1723.          *       return symbol_any;
  1724.          *     }
  1725.          */
  1726.         precision = N_AST1(constraint);
  1727.         range_constraint = N_AST2(constraint);
  1728.         base_precision = (Node) (SIGNATURE(type_mark))[4];
  1729.  
  1730.         if (is_generic_type(base_mark)) base_precision = precision;
  1731.         check_type((kind == symbol_float ? symbol_integer : symbol_real_type),
  1732.           precision);
  1733.  
  1734.         if (N_KIND(precision) == as_ivalue) {
  1735.             if (kind == symbol_float) {
  1736.                 digits = INTV((Const)N_VAL(precision));
  1737.                 if (digits < 1) {
  1738.                     errmsg("value for DIGITS must be positive", "3.5.7",
  1739.                       precision);
  1740.                 }
  1741.                 else if (digits > INTV((Const)N_VAL(base_precision))) {
  1742.                     warning(
  1743.                       "Evaluation of expression will raise CONSTRAINT_ERROR",
  1744.                       precision);
  1745.                 }
  1746.             }
  1747.             else {
  1748.                 delta = (Const) N_VAL(precision);
  1749.                 rdelta = RATV(delta);
  1750.                 /* need to declae [0, 1] as apropriate global ds 25 nov */
  1751.                 if (rat_lss(rdelta, rat_fri(int_fri(0), int_fri(1))))  {
  1752.                     errmsg("value of DELTA must be positive", "3.5.9",
  1753.                       precision);
  1754.                 }
  1755.                 /* TBSL: check translation of following    ds 26-nov-84*/
  1756.                 else if (rat_lss(rdelta, (RATV((Const)N_VAL(base_precision))))){
  1757.                     warning(
  1758.                       "Evaluation of expression will raise CONSTRAINT_ERROR",
  1759.                       precision);
  1760.                 }
  1761.             }
  1762.         }
  1763.         else {
  1764.             errmsg("expect static expression for DIGITS or DELTA",
  1765.               "3.5.7, 3.5.9", precision);
  1766.         }
  1767.         if (range_constraint != OPT_NODE) {
  1768.             lo = N_AST1(range_constraint);
  1769.             hi = N_AST2(range_constraint);
  1770.             check_type(base_mark, lo);
  1771.             check_type(base_mark, hi);
  1772.         }
  1773.         else {
  1774.             /* Only the precision was given in the constraint. */
  1775.             /* Obtain the bounds from the type itself.*/
  1776.             lo = (Node) numeric_constraint_low(old_c);
  1777.             hi = (Node) numeric_constraint_high(old_c);
  1778.         }
  1779.  
  1780.         if (constr_type == as_digits) {
  1781.             new_c = constraint_new(CONSTRAINT_DIGITS);
  1782.             numeric_constraint_digits(new_c) = (char *) precision;
  1783.         }
  1784.         else {
  1785.             int jk;
  1786.             new_c = constraint_new(CONSTRAINT_DELTA);
  1787.             numeric_constraint_delta(new_c) = (char *) precision;
  1788.             jk = power_of_2((Const) N_VAL(precision));
  1789.             numeric_constraint_small(new_c) =  (char *)new_ivalue_node(
  1790.               rat_const(power_of_2_small), get_type(precision));
  1791.         }
  1792.         numeric_constraint_low(new_c)  = (char *) lo;
  1793.         numeric_constraint_high(new_c) = (char *) hi;
  1794.     }
  1795.     else if (constr_type == as_attribute) {
  1796.         /* The constraint is given by a RANGE attribute which is folded
  1797.          * as_attribute in adasem routine. We get the bounds of the 
  1798.          * range to construct the new subtype.
  1799.          */
  1800.         attr_node = N_AST1(constraint);
  1801.         if ((int)attribute_kind(constraint) != ATTR_RANGE) {
  1802.             errmsg("Invalid expression for range constraint","3.3", constraint);
  1803.             return symbol_any;
  1804.         }
  1805.         else {
  1806.             check_type(base_mark, constraint);
  1807.             new_c = apply_range(constraint);
  1808.         }
  1809.     }
  1810.     else {
  1811.         errmsg("Invalid constraint for scalar type", "3.3.2", constraint);
  1812.         return symbol_any;
  1813.     }
  1814.     /* Verify that a discriminant does not appear in a scalar constraint.
  1815.      * This must be special-cased because discriminants are otherwise
  1816.      * allowed to appear in index and discriminant constraints, and in
  1817.      * initial values, i.e. arbitrary expressions.
  1818.      */
  1819.     check_discriminant(constraint);
  1820.  
  1821.     typ = named_type(strjoin("&", newat_str()));   /* Create a name for it*/
  1822.     NATURE(typ) = na_subtype;
  1823.     TYPE_OF(typ) = type_mark;
  1824.     SIGNATURE(typ) = (Tuple) new_c;
  1825.     return typ;
  1826. }
  1827.